home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
oobpls10.zip
/
DEGIF.PAS
next >
Wrap
Pascal/Delphi Source File
|
1992-11-06
|
13KB
|
508 lines
{$F+,A+,R-,S-,V-,O-,G+} {not recommended for overlaying! 286 req'd}
{***********************************************}
{* DEGIF.PAS 3.0b *}
{* Copyright (c) Steve Sneed 1991 *}
{* All Rights Reserved *}
{* *}
{* Provided to TurboPower Software for their *}
{* use or distribution with their products *}
{***********************************************}
{$IFNDEF Ver60}
{$IFNDEF Ver70}
!! FATAL: This unit requires TP6 or later !!
{$ENDIF}
{$ENDIF}
unit DeGIF; {basic GIF image decoder}
interface
const
UnitVers = '3.0b';
UnitDate = '08-Aug-92';
type
GetByteProc = function : Byte;
PutLineProc = procedure;
TRasterLine = Array[0..2047] of Byte;
type
{color map types needed}
MapType = (Global, Local);
GifBlockType = Array[0..255] of Byte;
Primary = (RedVal,GreenVal,BlueVal);
MapEntry = array[RedVal..BlueVal] of Byte;
{record of a color map}
GIFMap =
record
Map : array[0..255] of MapEntry;
MapExists : Boolean;
Sorted : Boolean;
BitsPerPixel : Word;
HighColorNum : Word;
IsGlobal : Boolean; {only true if Global}
BackgrColorIndex : Word; {only valid if Global}
AspectRatio : Word; {only valid if Global}
BitsPerPrimary : Word; {only valid if Global}
Interlaced : Boolean; {only valid if Local }
end;
var
RasterLine : TRasterLine;
RasterWidth : Word;
GetByte : GetByteProc;
PutLine : PutLineProc;
GifFile : File;
var
ExtendFunc : Byte; {Function code for extension block}
GIFSig : String[6]; {GIF ID string usually = 'GIF87a'}
ImageLeft, {Left edge of image relative to virtual screen}
ImageTop, {Top edge of image relative to virtual screen}
ImageWidth, {in pixels}
ImageHeight, {in pixels}
LeftEdge,
RightEdge,
ScrColors,
ScrHeight, {in pixels}
ScrWidth : Word; {in pixels}
{vars used by decompressor}
PackedBits, I : Word;
A, B : Byte;
BytesInBlock : Byte;
{color mapping services vars}
Maps : Array[MapType] of GIFMap;
CurMap : MapType;
TempMap : GIFMap;
Color : array[0..255] of byte;
MaxColors : Integer;
{-GIF decode routines}
procedure GetGIFSig;
procedure GetImageDescription(var MapRec : GifMap);
procedure GetScrDes(var MapRec : GifMap);
procedure GetBlock(var Block : GifBlockType);
function GetExtendFunc : Byte;
function GetExtendBlock(var Block : GifBlockType) : Boolean;
procedure SkipExtendBlock;
function ExpandGIF : Integer;
implementation
const
LargestCode = 4095;
type
CodeEntry =
Record
Prefix: Integer; { 2 bytes }
Suffix: Byte; { 1 byte }
Stack: Byte; { 1 byte }
end; { 4096 * 4 = 16k }
TCodeTable = Array[0..LargestCode] of CodeEntry;
PCodeTable = ^TCodeTable;
const
Mask: Array[1..12] of Integer = ($0001,$0003,$0007,$000F,
$001F,$003F,$007F,$00FF,
$01FF,$03FF,$07FF,$0FFF);
var
CodeSize,
ClearCode,
EOFCode,
FirstFree,
BitOffset,
BytOffset,
BitsLeft,
MaxCode,
FreeCode,
OldCode,
InputCode,
Code,
SuffixChar,
FinalChar,
MinimumCodeSize,
BytesUnRead : Integer;
CodeBuffer : Array[0..260] of Byte;
CodeTable : PCodeTable;
RasterPos : Word;
ExpError : Integer;
function GetWord : word;
{-get two bytes and make a word}
begin
a := GetByte;
b := GetByte;
GetWord := (b shl 8) or a;
end;
function GetWordFromBlock(var Block : GifBlockType; Index : byte) : word;
{-get a word from a block}
begin
GetWordFromBlock := (Block[succ(Index)] shl 8) or Block[Index];
end;
procedure GetBlock(var Block : GifBlockType);
{-get next block of GIF stream}
begin
Block[0] := GetByte;
if Block[0] <> 0 then
for I := 1 to Block[0] do Block[I] := GetByte;
end;
procedure GetGIFSig;
{-get the 6-byte GIF signature}
var I : Integer;
begin
GIFSig := '';
for I := 0 to 5 do
GIFSig := GIFSig + chr(GetByte);
end;
procedure GetScrDes(var MapRec : GifMap);
{-get a screen descriptor record}
begin
ScrWidth := GetWord;
RasterWidth := ScrWidth;
ScrHeight := GetWord;
PackedBits := GetByte;
with MapRec do begin
IsGlobal := true;
Interlaced := false; {undefined}
BitsPerPrimary := ((PackedBits and $70) shr 4) + 1;
BackgrColorIndex := GetByte;
MapExists := (PackedBits and $80) <> 0;
BitsPerPixel := (PackedBits and $7) + 1;
HighColorNum := (1 shl BitsPerPixel)-1;
ScrColors := Succ(HighColorNum);
Sorted := (PackedBits and $04) <> 0;
AspectRatio := GetByte;
if MapExists then {get the map}
for I := 0 to HighColorNum do begin
Map[I,RedVal] := GetByte;
Map[I,GreenVal] := GetByte;
Map[I,BlueVal] := GetByte
end;
end;
end;
procedure GetImageDescription(var MapRec : GifMap);
{-get an image descriptor record}
begin
ImageLeft := GetWord;
ImageTop := GetWord;
ImageWidth := GetWord;
ImageHeight := GetWord;
PackedBits := GetByte;
with MapRec do begin
IsGlobal := false;
AspectRatio := 0; {undefined}
BitsPerPrimary := 0; {undefined}
BackgrColorIndex := 0; {undefined}
Interlaced := (PackedBits and $40) <> 0;
Sorted := (PackedBits and $20) <> 0;
MapExists := (PackedBits and $80) <> 0;
BitsPerPixel := (PackedBits and $7)+1;
HighColorNum := (1 shl BitsPerPixel)-1;
if MapExists then
for I := 0 to HighColorNum do begin
Map[I,RedVal] := GetByte;
Map[I,GreenVal] := GetByte;
Map[I,BlueVal] := GetByte
end;
end;
end;
function GetExtendFunc : Byte;
begin
GetExtendFunc := GetByte;
end;
function GetExtendBlock(var Block : GifBlockType) : Boolean;
begin
GetBlock(Block);
GetExtendBlock := (Block[0] <> 0);
end;
procedure SkipExtendBlock;
{-skip 89a-spec extension block}
var
Block : GifBlockType;
begin
GetExtendFunc;
while GetExtendBlock(Block) do ;
end;
procedure InitializeTable;
begin
CodeSize := Succ(MinimumCodeSize);
ClearCode := 1 Shl MinimumCodeSize;
EOFCode := Succ(ClearCode);
FirstFree := Succ(EOFCode);
FreeCode := FirstFree;
MaxCode := 1 Shl CodeSize;
end;
procedure ReadBuffer;
var
I : Integer;
B : Byte;
BufPointer : Integer;
RC : Integer;
Reading : Boolean;
begin
BufPointer := 0;
for I := BytOffset to 63 do begin
CodeBuffer[BufPointer] := CodeBuffer[i];
Inc(BufPointer);
end;
Reading := True;
While Reading do begin
If BytesUnRead = 0 then
BytesUnRead := GetByte;
If BytesUnRead < 1 then begin
Reading := False;
If BytesUnRead < 0 then
ExpError := BytesUnRead;
end;
If Reading then begin
CodeBuffer[BufPointer] := GetByte;
Dec(BytesUnRead);
Inc(BufPointer);
Reading := (BufPointer < 64);
end;
end;
BitOffset := BitsLeft;
BytOffset := 0;
end;
function ReadCode : Integer;
var
L : LongInt;
begin
asm
mov ax,BitOffset
push ax
and ax,0007
mov BitsLeft,ax
pop ax
shr ax,3
mov BytOffset,ax
cmp ax,61
jb @@NoLoad
call ReadBuffer
@@NoLoad:
mov ax,BitOffset
add ax,CodeSize
mov BitOffset,ax
mov si,offset CodeBuffer
mov bx,[BytOffset]
mov ax,[si+bx]
mov dx,[si+bx+2]
xor dh,dh
mov cx,[BitsLeft]
jcxz @@NoShift
@@Shift1:
dec cx
jl @@NoShift
shr dx,1
rcr ax,1
jmp @@Shift1
@@NoShift:
mov si,offset Mask
mov bx,[CodeSize]
dec bx
shl bx,1
mov cx,[si+bx]
and ax,cx
mov [bp-02],ax
end;
end;
procedure PutByte(B : Byte); Assembler;
asm
mov al,B
mov si,offset RasterLine
mov bx,[RasterPos]
mov [si+bx],al
inc bx
cmp bx,[ImageWidth]
jb @@NoReset
call PutLine
xor bx,bx
@@NoReset:
mov [RasterPos],bx
end;
function ExpandGif: Integer;
label
Breakout;
var
I, SPt : Integer;
begin
ExpandGIF := -2;
GetMem(CodeTable, SizeOf(TCodeTable));
if CodeTable = nil then
exit;
FillChar(CodeTable^,SizeOf(TCodeTable),0);
Code := 0;
OldCode := 0;
SuffixChar := 0;
FinalChar := 0;
RasterPos := 0;
MinimumCodeSize := GetByte;
If MinimumCodeSize < 0 then
ExpError := MinimumCodeSize
else if not (MinimumCodeSize in [2..9]) then begin
ExpandGIF := -1;
goto Breakout;
end
else begin
ExpandGIF := 0;
InitializeTable;
SPt := 0;
BytesUnRead := 0;
BitOffset := 64*8;
asm
@@Top:
call ReadCode
mov [Code],ax
cmp ax,[EOFCode]
je Breakout
cmp ax,[ClearCode]
jne @@Skip1
call InitializeTable
call ReadCode
mov [Code],ax
mov [OldCode],ax
mov [SuffixChar],ax
mov [FinalChar],ax
mov si,offset [Color]
add si,ax
mov ax,ds:[si]
push ax
call PutByte
jmp @@Top
@@Skip1:
mov ax,[Code]
mov [InputCode],ax
cmp ax,[FreeCode]
jb @@Skip2
mov ax,[OldCode]
mov [Code],ax
les di,CodeTable
mov ax,[SPt]
push ax
shl ax,2
add di,ax
mov ax,[FinalChar]
mov es:[di+3],ax
pop ax
inc ax
mov [SPt],ax
@@Skip2:
mov ax,[Code]
cmp ax,[FirstFree]
jb @@Skip3
shl ax,2
les di,CodeTable
add di,ax
mov dl,es:[di+2]
mov ax,[SPt]
shl ax,2
les di,CodeTable
add di,ax
mov es:[di+3],dl
mov ax,[Code]
shl ax,2
les di,CodeTable
add di,ax
mov ax,es:[di]
mov [Code],ax
inc word ptr [SPt]
jmp @@Skip2
@@Skip3:
mov [FinalChar],ax
mov [SuffixChar],ax
mov dx,ax
mov ax,[SPt]
shl ax,2
les di,CodeTable
add di,ax
mov es:[di+3],dl
inc [SPt]
@@Skip4:
cmp [SPt],0
je @@Skip5
dec [SPt]
mov ax,[SPt]
shl ax,2
les di,CodeTable
add di,ax
mov bl,es:[di+3]
xor bh,bh
mov si,offset [Color]
add si,bx
mov al,[si]
xor ah,ah
push ax
call PutByte
jmp @@Skip4
@@Skip5:
mov ax,[FreeCode]
shl ax,2
les di,CodeTable
add di,ax
mov ax,[OldCode]
mov es:[di],ax
add di,2
mov ax,[SuffixChar]
mov es:[di],al
mov ax,[InputCode]
mov [OldCode],ax
mov ax,[FreeCode]
inc ax
mov [FreeCode],ax
cmp ax,[MaxCode]
jb @@Skip6
mov ax,[CodeSize]
cmp ax,11
ja @@Skip6
inc ax
mov [CodeSize],ax
mov ax,[MaxCode]
shl ax,1
mov [MaxCode],ax
@@Skip6:
jmp @@Top
end;
end;
Breakout:
FreeMem(CodeTable, SizeOf(TCodeTable));
end;
end.